home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / source / obrn-a_1.5_src.lha / oberon-a / source3.lha / Source / OD / ODT.mod < prev   
Encoding:
Text File  |  1995-01-26  |  41.4 KB  |  1,482 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: ODT.mod $
  4.   Description: Symbol table handler for OD.
  5.  
  6.                This module is adapted from Modules OCG and OCT, which are
  7.                part of the Oberon-A compiler 'OC'.
  8.  
  9.    Created by: fjc (Frank Copeland)
  10.     $Revision: 1.5 $
  11.       $Author: fjc $
  12.         $Date: 1995/01/26 02:00:59 $
  13.  
  14.   Copyright © 1994-1995, Frank Copeland.
  15.   This file is part of Oberon-A.
  16.   See Oberon-A.doc for conditions of use and distribution.
  17.  
  18.   Log entries are at the end of the file.
  19.  
  20. *************************************************************************)
  21.  
  22. <*STANDARD-*>
  23.  
  24. MODULE ODT;
  25.  
  26. IMPORT
  27.   SYS := SYSTEM, e := Exec, d := Dos, du := DosUtil, f := Files, Reals,
  28.   str := Strings, ODRev, ODStrings;
  29.  
  30. (*
  31. ** Object and item modes. These are the same as those declared in module
  32. ** OCG and must be updated if that module is changed.
  33. *)
  34.  
  35. CONST
  36.  
  37.   Undef   =  0;
  38.   Var     =  1; (* local and global variables and value parameters *)
  39.   VarX    =  2; (* indexed array variables *)
  40.   VarArg  =  3; (* C-style vararg pushed on stack *)
  41.   Ind     =  4; (* variable parameters *)
  42.   IndX    =  5; (* indexed dynamic array parameters *)
  43.   RegI    =  6; (* register indirect mode with displacement *)
  44.   RegX    =  7; (* register indirect mode with displacement and index *)
  45.   Lab     =  8; (* absolute mode, the address of a label *)
  46.   LabI    =  9; (* immediate mode, the address of a label *)
  47.   Abs     = 10; (* absolute mode *)
  48.   Con     = 11; (* constants *)
  49.   Push    = 12; (* register indirect mode with predecrement *)
  50.   Pop     = 13; (* register indirect mode with postincrement *)
  51.   Coc     = 14; (* condition code *)
  52.   Reg     = 15; (* register direct mode *)
  53.   Fld     = 16; (* record fields *)
  54.   Typ     = 17; (* types *)
  55.   LProc   = 18; (* local (non-exportable) procedures *)
  56.   XProc   = 19; (* exportable procedures *)
  57.   TProc   = 20; (* Type-bound procedures *)
  58.   SProc   = 21; (* standard procedures *)
  59.   LibCall = 22; (* Amiga library functions (new) *)
  60.   M2Proc  = 23; (* External procedure (Modula-2 conventions) *)
  61.   CProc   = 24; (* External procedurm (C conventions) *)
  62.   AProc   = 25; (* External procedure (Assembly conventions) *)
  63.   Mod     = 26; (* Modules *)
  64.   Head    = 27; (* symbol scope header *)
  65.   RList   = 28; (* Register list for MOVEM *)
  66.   HPtr    = 29; (* Hidden pointer record field *)
  67.  
  68. (* System flags, used in the foreign code interface *)
  69.  
  70.   DefaultFlag = -1; (* Use current default *)
  71.   OberonFlag  =  0; (* Use Oberon conventions (default) *)
  72.   M2Flag      =  1; (* Use Modula-2 conventions *)
  73.   CFlag       =  2; (* Use C conventions *)
  74.   BCPLFlag    =  3; (* Use BCPL conventions *)
  75.   AsmFlag     =  4; (* Use Assembler conventions *)
  76.  
  77.   (* Sizes in bytes of basic data types. *)
  78.  
  79.   ByteSize = 1; WordSize = 2; LongSize = 4;
  80.   BoolSize = 1; CharSize = 1;
  81.   SIntSize = 1; IntSize = 2; LIntSize = 4;
  82.   RealSize = 4; LRealSize = RealSize;
  83.   BSetSize = 1; WSetSize = 2; SetSize = 4;
  84.   PtrSize  = 4; ProcSize = 4;
  85.  
  86. (*
  87. ** The following declarations are adapted from Module OCT. They must be
  88. ** updated if that module is changed.
  89. *)
  90.  
  91. CONST
  92.  
  93.   maxImps = 32;
  94.  
  95.   (* structure forms *)
  96.  
  97.   Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5;
  98.   LInt = 6; Real = 7; LReal = 8; BSet = 9; WSet = 10; Set = 11;
  99.   String = 12; NilTyp = 13; NoTyp = 14; PtrTyp = 15; AdrTyp = 16;
  100.   BPtrTyp = 17; Word = 18; Longword = 19; TagTyp = 20;
  101.   Pointer = 21; ProcTyp = 24; Array = 25; DynArr = 26;
  102.   Record = 27;
  103.  
  104.   (* String lengths *)
  105.  
  106.   NameLen = 255;
  107.   PathLen = 256;
  108.  
  109.   (* Values for visible field of ObjDesc *)
  110.  
  111.   Exp = -1;
  112.   NotExp = 0;
  113.   RdOnly = 1;
  114.  
  115. TYPE
  116.  
  117.   Name = ARRAY NameLen + 1 OF CHAR;
  118.   Symbol = POINTER TO ARRAY OF CHAR;
  119.  
  120.   Object = POINTER TO ObjDesc;
  121.   Struct = POINTER TO StrDesc;
  122.  
  123.   ObjDesc = RECORD
  124.     left, right, link : Object;
  125.     typ : Struct;
  126.     a0, a1 : LONGINT;
  127.     a2 : INTEGER;
  128.     mode : SHORTINT;
  129.     visible : SHORTINT;
  130.     name : LONGINT;
  131.     symbol : Symbol;
  132.   END; (* ObjDesc *)
  133.  
  134.   ActionProc = PROCEDURE (obj : Object);
  135.  
  136.   StrDesc = RECORD
  137.     form, mno, sysflg : INTEGER;
  138.     n, size, adr : LONGINT;
  139.     BaseTyp : Struct;
  140.     link, strobj : Object;
  141.   END; (* StrDesc *)
  142.  
  143. VAR
  144.   topScope : Object;
  145.  
  146.   undftyp, bytetyp, booltyp, chartyp, sinttyp, inttyp,
  147.   linttyp, realtyp, lrltyp, settyp, stringtyp, niltyp, notyp,
  148.   ptrtyp, adrtyp, bptrtyp, bsettyp, wsettyp, wordtyp,
  149.   lwordtyp, tagtyp
  150.     : Struct;
  151.  
  152.   nofGmod : INTEGER; (* nof imports *)
  153.   GlbMod : ARRAY maxImps OF Object;
  154.  
  155. CONST
  156.  
  157.   SFtag = 53594D08H; (* "SYM" + version # *)
  158.   firstStr = 32; maxStr = 512;
  159.   maxMod = 24; maxParLev = 6;
  160.   NotYetExp = 0; maxExtLib = 8;
  161.  
  162.   (* terminal symbols for symbol file elements *)
  163.  
  164.   eUndef = 0; eCon = 1; eTypE = 2; eTyp = 3; eVar = 4; eXProc = 5;
  165.   eLibCall = 6; eM2Proc = 7; eCProc = 8; eAProc = 9; ePointer = 10;
  166.   eProcTyp = 11; eArray = 12; eDynArr = 13; eRecord = 14; eParList = 15;
  167.   eValPar = 16; eVarPar = 17; eVarArg = 18; eFldList = 19; eFld = 20;
  168.   eHPtr = 21; eHProc = 22; eTProcE = 23; eTProc = 24; eFixup = 25;
  169.   eMod = 26; eExtLib = 27;
  170.  
  171.   (* name buffer size *)
  172.  
  173.   BufSize = 16384;
  174.   MaxBuffers = 16;
  175.   HashTableSize = 251;
  176.  
  177. TYPE
  178.  
  179.   NameBufPtr = POINTER TO ARRAY BufSize OF CHAR;
  180.  
  181. VAR
  182.   universe, syslink : Object;
  183.   SR : f.Rider;
  184.   nameBuf : ARRAY MaxBuffers OF NameBufPtr;
  185.   nameX, nameOrg, nameSize : LONGINT;
  186.   nameTab, backupTab : ARRAY HashTableSize OF LONGINT;
  187.   ObjectList : Object;
  188.   StructList : Struct;
  189.  
  190.   (* These are assumed to have all fields zeroed by the loader. *)
  191.   emptyObj  : ObjDesc;
  192.   emptyStr  : StrDesc;
  193.  
  194.   nofExtLib : INTEGER;
  195.   extLib : ARRAY maxExtLib OF LONGINT;
  196.  
  197.   indentLevel : INTEGER;
  198.   name : Name;
  199.   external *, size *, expand * : BOOLEAN;
  200.   wroteConst, wroteType, wroteVar, wroteProcs : BOOLEAN;
  201.  
  202. (*--- CONSOLE IO ---------------------------------*)
  203.  
  204. (*
  205. ** Console I/O
  206. *)
  207.  
  208. (*------------------------------------*)
  209. PROCEDURE OutStr ( string : ARRAY OF CHAR );
  210. <*$CopyArrays-*>
  211. BEGIN (* OutStr *)
  212.   du.HaltIfBreak ({d.ctrlC});
  213.   IF d.PutStr (string) = 0 THEN END;
  214. END OutStr;
  215.  
  216.  
  217. (*------------------------------------*)
  218. PROCEDURE OutChar ( c : CHAR );
  219. BEGIN (* OutChar *)
  220.   du.HaltIfBreak ({d.ctrlC});
  221.   d.PrintF ("%lc", c)
  222. END OutChar;
  223.  
  224.  
  225. (*------------------------------------*)
  226. PROCEDURE OutLn;
  227. BEGIN (* OutLn *)
  228.   OutChar ("\n")
  229. END OutLn;
  230.  
  231.  
  232. (*------------------------------------*)
  233. PROCEDURE OutStr0 ( n : LONGINT );
  234.   VAR string : e.LSTRPTR;
  235. BEGIN (* OutStr0 *)
  236.   du.HaltIfBreak ({d.ctrlC});
  237.   string := ODStrings.GetString (n);
  238.   IF d.PutStr (string^) = 0 THEN END;
  239. END OutStr0;
  240.  
  241.  
  242. (*------------------------------------*)
  243. PROCEDURE OutStr1 ( n : LONGINT; string : ARRAY OF CHAR );
  244.   VAR format : e.LSTRPTR;
  245. <*$CopyArrays-*>
  246. BEGIN (* OutStr1 *)
  247.   du.HaltIfBreak ({d.ctrlC});
  248.   format := ODStrings.GetString (n);
  249.   d.PrintF (format^, SYS.ADR (string));
  250. END OutStr1;
  251.  
  252.  
  253. (*--- MEMORY MANAGEMENT ---------------------------------*)
  254.  
  255. (*------------------------------------*)
  256. PROCEDURE AllocObj () : Object;
  257.  
  258.   VAR newObj : Object;
  259.  
  260. BEGIN (* AllocObj *)
  261.   IF ObjectList = NIL THEN
  262.     NEW (newObj)
  263.   ELSE
  264.     newObj := ObjectList; ObjectList := ObjectList.link
  265.   END;
  266.   newObj^ := emptyObj;
  267.   RETURN newObj
  268. END AllocObj;
  269.  
  270. (*------------------------------------*)
  271. PROCEDURE FreeObj (obj : Object);
  272.  
  273. BEGIN (* FreeObj *)
  274.   IF obj # NIL THEN
  275.     FreeObj (obj.left); FreeObj (obj.right);
  276.     obj^ := emptyObj;
  277.     obj.link := ObjectList; ObjectList := obj
  278.   END
  279. END FreeObj;
  280.  
  281. (*------------------------------------*)
  282. PROCEDURE AllocStruct () : Struct;
  283.  
  284.   VAR newStr : Struct;
  285.  
  286. BEGIN (* AllocStruct *)
  287.   IF StructList = NIL THEN
  288.     NEW (newStr)
  289.   ELSE
  290.     newStr := StructList; StructList := StructList.BaseTyp;
  291.     newStr.BaseTyp := NIL
  292.   END;
  293.   RETURN newStr
  294. END AllocStruct;
  295.  
  296. (*------------------------------------*)
  297. PROCEDURE FreeStruct (str : Struct);
  298.  
  299. BEGIN (* FreeStruct *)
  300.   IF str # NIL THEN
  301.     FreeObj (str.link); str^ := emptyStr;
  302.     str.BaseTyp := StructList; StructList := str
  303.   END
  304. END FreeStruct;
  305.  
  306. (*--- NAME TABLE HANDLER ---------------------------------*)
  307.  
  308. (*------------------------------------*)
  309. PROCEDURE CheckBuf (size : LONGINT);
  310.  
  311.   VAR newBuf : NameBufPtr; newX : LONGINT;
  312.  
  313. BEGIN (* CheckBuf *)
  314.   newX := nameX + size + 4;
  315.   IF newX >= nameSize THEN
  316.     IF newX >= BufSize * MaxBuffers THEN
  317.       OutStr0 (ODStrings.errNameBuffer); nameX := 0
  318.     ELSE
  319.       IF ((newX-1) MOD BufSize) < (size+4) THEN nameX := nameSize END;
  320.       NEW (newBuf);
  321.       INC (nameSize, BufSize);
  322.       nameBuf [(nameSize - 1) DIV BufSize] := newBuf
  323.     END
  324.   END
  325. END CheckBuf;
  326.  
  327. (*------------------------------------*)
  328. PROCEDURE InsertName (n : ARRAY OF CHAR) : LONGINT;
  329.  
  330.   VAR i, j, k, len, bufX : INTEGER; x, x1 : LONGINT; ch : CHAR;
  331.       buf : NameBufPtr;
  332.  
  333. <*$CopyArrays-*>
  334. BEGIN (* InsertName *)
  335.   k := 0; len := 0; ch := n [0];
  336.   WHILE ch # 0X DO
  337.     <*$ < OvflChk- *>
  338.     INC (k, ORD (ch));
  339.     <*$ > *>
  340.     INC (len); ch := n [len]
  341.   END;
  342.   k := (k + len) MOD HashTableSize;
  343.   x := nameTab [k];
  344.   LOOP
  345.     IF x = 0 THEN
  346.       CheckBuf (len);
  347.       buf := nameBuf [nameX DIV BufSize];
  348.       bufX := SHORT (nameX MOD BufSize);
  349.       buf [bufX] := CHR (nameTab [k] DIV 10000H); INC (bufX);
  350.       buf [bufX] := CHR (nameTab [k] DIV 100H);   INC (bufX);
  351.       buf [bufX] := CHR (nameTab [k]);            INC (bufX);
  352.       i := 0;
  353.       WHILE i <= len DO buf [bufX] := n [i]; INC (bufX); INC (i) END;
  354.       x := nameX + 3; nameTab [k] := x; nameX := nameX + len + 4;
  355.       RETURN x
  356.     ELSE
  357.       buf := nameBuf [x DIV BufSize];
  358.       bufX := SHORT (x MOD BufSize);
  359.       x1 :=
  360.         (LONG (ORD (buf [bufX - 3])) * 10000H)
  361.         + (LONG (ORD (buf [bufX - 2])) * 100H)
  362.         + LONG (ORD (buf [bufX - 1]));
  363.       i := bufX; j := 0;
  364.       LOOP
  365.         IF buf [i] # n [j] THEN
  366.           x := x1; EXIT
  367.         ELSIF n [j] = 0X THEN
  368.           RETURN x
  369.         ELSE
  370.           INC (i); INC (j)
  371.         END
  372.       END
  373.     END; (* ELSE *)
  374.   END; (* LOOP *)
  375. END InsertName;
  376.  
  377. (*------------------------------------*)
  378. PROCEDURE NameLength (name : LONGINT) : INTEGER;
  379.  
  380.   VAR buf : NameBufPtr; len, bufX : INTEGER;
  381.  
  382. BEGIN (* NameLength *)
  383.   buf := nameBuf [name DIV BufSize];
  384.   bufX := SHORT (name MOD BufSize);
  385.   len := 0;
  386.   WHILE buf [bufX] # 0X DO INC (len); INC (bufX) END;
  387.   RETURN len
  388. END NameLength;
  389.  
  390. (*------------------------------------*)
  391. PROCEDURE GetName (adr : LONGINT);
  392.  
  393.   VAR buf : NameBufPtr; i, bufX : INTEGER; ch :  CHAR;
  394.  
  395. BEGIN (* GetName *)
  396.   buf := nameBuf [adr DIV BufSize];
  397.   bufX := SHORT (adr MOD BufSize);
  398.   i := 0;
  399.   REPEAT
  400.     ch := buf [bufX]; name [i] := ch;
  401.     INC (i); INC (bufX)
  402.   UNTIL ch = 0X;
  403. END GetName;
  404.  
  405. (*--- TABLE INSERTION ---------------------------------*)
  406.  
  407. (*------------------------------------*)
  408. PROCEDURE InsertObj
  409.   ( VAR name : ARRAY OF CHAR; root : Object; mode : SHORTINT;
  410.     VAR res : Object ) : BOOLEAN;
  411.  
  412.   VAR
  413.     obj, prev : Object; result : BOOLEAN;
  414.     buf : NameBufPtr; n1, n2 : LONGINT; bufX, i : INTEGER; ch1, ch2 : CHAR;
  415.  
  416. BEGIN (* InsertObj *)
  417.   prev := root; obj := root.link; n1 := InsertName (name);
  418.   WHILE (obj # NIL) & (obj.name # n1) DO
  419.     prev := obj; n2 := obj.name; i := 0;
  420.     buf := nameBuf [n2 DIV BufSize]; bufX := SHORT (n2 MOD BufSize);
  421.     REPEAT
  422.       ch1 := name [i]; INC (i);
  423.       ch2 := buf [bufX]; INC (bufX)
  424.     UNTIL ch1 # ch2;
  425.     IF ch1 < ch2 THEN obj := obj.left
  426.     ELSE obj := obj.right
  427.     END
  428.   END;
  429.   IF obj = NIL THEN
  430.     obj := AllocObj (); obj.name := n1; obj.mode := mode;
  431.     IF prev = root THEN
  432.       root.link := obj
  433.     ELSE
  434.       IF ch1 < ch2 THEN prev.left := obj
  435.       ELSE prev.right := obj
  436.       END
  437.     END;
  438.     result := TRUE
  439.   ELSE
  440.     result := FALSE
  441.   END;
  442.   res := obj;
  443.   RETURN result
  444. END InsertObj;
  445.  
  446. (*------------------------------------*)
  447. PROCEDURE Insert
  448.   ( VAR name : ARRAY OF CHAR;
  449.     VAR res : Object;
  450.     mode : SHORTINT );
  451.  
  452. BEGIN (* Insert *)
  453.   IF ~InsertObj (name, topScope, mode, res) THEN
  454.     IF res.mode # Undef THEN OutStr0 (ODStrings.errDupName) END;
  455.     res.mode := mode
  456.   END
  457. END Insert;
  458.  
  459. (*------------------------------------*)
  460. PROCEDURE ExtLib ( name : ARRAY OF CHAR );
  461. <*$CopyArrays-*>
  462. BEGIN (* ExtLib *)
  463.   IF nofExtLib >= maxExtLib THEN
  464.     OutStr0 (ODStrings.errExtLibs); nofExtLib := 0
  465.   END;
  466.   extLib [nofExtLib] := InsertName (name); INC (nofExtLib)
  467. END ExtLib;
  468.  
  469. (*------------------------------------*)
  470. PROCEDURE OpenScope (level : INTEGER);
  471.  
  472.   VAR head : Object;
  473.  
  474. BEGIN (* OpenScope *)
  475.   head := AllocObj ();
  476.   head.mode := Head; head.a0 := level; head.left := topScope;
  477.   topScope := head;
  478. END OpenScope;
  479.  
  480. (*------------------------------------*)
  481. PROCEDURE CloseScope ();
  482.  
  483.   VAR oldHead : Object;
  484.  
  485. BEGIN (* CloseScope *)
  486.   oldHead := topScope; topScope := topScope.left;
  487.   oldHead^ := emptyObj; oldHead.link := ObjectList; ObjectList := oldHead;
  488. END CloseScope;
  489.  
  490. (*--- MODULE INITIALISATION ---------------------------------*)
  491.  
  492. (*------------------------------------*)
  493. PROCEDURE Init * ();
  494.  
  495. BEGIN (* Init *)
  496.   topScope := universe; nofGmod := 0; nofExtLib := 0;
  497.   wroteConst := FALSE; wroteType := FALSE; wroteVar := FALSE;
  498.   wroteProcs := FALSE
  499. END Init;
  500.  
  501. (*------------------------------------*)
  502. PROCEDURE Close * ();
  503.  
  504.   VAR i : INTEGER;
  505.  
  506. BEGIN (* Close *)
  507.   f.Set (SR, NIL, 0);
  508.   i := 0; WHILE i < maxImps DO GlbMod [i] := NIL; INC (i) END;
  509.   (* Restore original hash table for reserved names... *)
  510.   nameTab := backupTab; nameX := nameOrg;
  511.   (* ... Assuming that only one name buffer is required *)
  512.   nameSize := BufSize;
  513.   i := 1; WHILE i < MaxBuffers DO nameBuf [i] := NIL; INC (i) END
  514. END Close;
  515.  
  516. (*--- IMPORT ---------------------------------*)
  517.  
  518. (*------------------------------------*)
  519. PROCEDURE ReadInt(VAR i: LONGINT);
  520. (*
  521.   Reads integers written in a compacted form. Taken from J. Templ.
  522.   SPARC-Oberon. User's Guide and Implementation. Computersysteme ETH
  523.   Zürich, Technical Report No. 133, June 1990.
  524. *)
  525.  
  526.   VAR n: LONGINT; s: INTEGER; x: CHAR;
  527.  
  528. BEGIN
  529.   s := 0; n := 0; f.Read(SR, x);
  530.   WHILE ORD(x) >= 128 DO
  531.     INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); f.Read(SR, x)
  532.   END;
  533.   i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s)
  534. END ReadInt;
  535.  
  536. (*------------------------------------*)
  537. PROCEDURE ReadLInt (VAR k : LONGINT);
  538.  
  539. BEGIN (* ReadLInt *)
  540.   f.ReadBytes (SR, k, 4);
  541. END ReadLInt;
  542.  
  543. (*------------------------------------*)
  544. PROCEDURE ReadId (VAR id : ARRAY OF CHAR);
  545.  
  546.   VAR i : INTEGER; ch : CHAR;
  547.  
  548. BEGIN (* ReadId *)
  549.   i := 0;
  550.   REPEAT
  551.     f.Read (SR, ch); id [i] := ch; INC (i)
  552.   UNTIL ch = 0X;
  553. END ReadId;
  554.  
  555. (*------------------------------------*)
  556. PROCEDURE Import *
  557.   ( FileName : ARRAY OF CHAR;
  558.     VAR name : ARRAY OF CHAR )
  559.   : BOOLEAN;
  560.  
  561.   VAR
  562.     i, m, s, nofLmod, strno, parlev, fldlev : INTEGER;
  563.     k, l, modname : LONGINT;
  564.     obj : Object;
  565.     modobj : Object;
  566.     class : SHORTINT;
  567.     SymFile : f.File;
  568.     LocMod : ARRAY maxMod OF Object;
  569.     struct : ARRAY maxStr OF Struct;
  570.     lastpar, lastfld : ARRAY maxParLev OF Object;
  571.     result : BOOLEAN;
  572.  
  573.     link : Object;
  574.     typ : Struct;
  575.     a0, a1 : LONGINT;
  576.     a2 : INTEGER;
  577.     mode : SHORTINT;
  578.     visible : SHORTINT;
  579.     symbol : Symbol;
  580.     objName : ARRAY NameLen+1 OF CHAR;
  581.  
  582.   (*------------------------------------*)
  583.   PROCEDURE reversedList (p : Object) : Object;
  584.  
  585.     VAR q, r : Object;
  586.  
  587.   BEGIN (* reversedList *)
  588.     q := NIL;
  589.     WHILE p # NIL DO r := p.link; p.link := q; q := p; p := r END;
  590.     RETURN q
  591.   END reversedList;
  592.  
  593.   (*------------------------------------*)
  594.   PROCEDURE reversedList2 (p : Object) : Object;
  595.  
  596.     VAR q, r : Object;
  597.  
  598.   BEGIN (* reversedList2 *)
  599.     q := NIL;
  600.     WHILE p # NIL DO r := p.left; p.left := q; q := p; p := r END;
  601.     RETURN q
  602.   END reversedList2;
  603.  
  604. <*$CopyArrays-*>
  605. BEGIN (* Import *)
  606.   result := FALSE;
  607.   nofLmod := 0; strno := firstStr; parlev := -1; fldlev := -1;
  608.   SymFile := f.Old (FileName);
  609.   IF SymFile # NIL THEN
  610.     OutStr ("\x9B\x4B << "); OutStr (FileName); OutChar ("\r");
  611.     f.Set (SR, SymFile, 0); ReadLInt (k);
  612.     IF k = SFtag THEN
  613.       struct [Undef] := undftyp; struct [Byte] := bytetyp;
  614.       struct [Bool] := booltyp; struct [Char] := chartyp;
  615.       struct [SInt] := sinttyp; struct [Int] := inttyp;
  616.       struct [LInt] := linttyp; struct [Real] := realtyp;
  617.       struct [LReal] := lrltyp; struct [Set] := settyp;
  618.       struct [String] := stringtyp; struct [NilTyp] := niltyp;
  619.       struct [NoTyp] := notyp; struct [BSet] := bsettyp;
  620.       struct [WSet] := wsettyp; struct [PtrTyp] := ptrtyp;
  621.       struct [AdrTyp] := adrtyp; struct [BPtrTyp] := bptrtyp;
  622.       struct [Word] := wordtyp; struct [Longword] := lwordtyp;
  623.       struct [TagTyp] := tagtyp;
  624.       LOOP (* read next item from symbol file *)
  625.         f.Read (SR, class); IF SR.eof THEN EXIT END;
  626.         link := NIL; typ := NIL; a0 := 0; a1 := 0; a2 := 0;
  627.         mode := Undef; visible := NotExp; symbol := NIL;
  628.         objName := "";
  629.         CASE class OF
  630.           eUndef : OutStr0 (ODStrings.errCorrupt)
  631.           |
  632.           eCon .. eAProc : (* object *)
  633.             m := 0; ReadInt (l); s := SHORT (l); typ := struct [s];
  634.             CASE class OF
  635.               eCon :
  636.                 mode := Con;
  637.                 CASE typ.form OF
  638.                   Byte, Char, BSet, Bool, SInt, Int, WSet,
  639.                   Word, LInt, Real, LReal, Set, Longword :
  640.                     ReadInt (a0);
  641.                   |
  642.                   (*LReal : ReadInt (a0); ReadInt (a1);
  643.                   |*)
  644.                   String :
  645.                     ReadInt (a0); ReadInt (a1);
  646.                     IF a1 <= 2 THEN
  647.                       ReadInt (l); a2 := SHORT (l)
  648.                     END
  649.                   |
  650.                   NilTyp : (* NIL *)
  651.                   |
  652.                   AdrTyp, BPtrTyp, Pointer, ProcTyp :
  653.                     (* This is all VERY dodgy, but ... *)
  654.                     ReadInt (a0)
  655.                   |
  656.                 ELSE
  657.                   OutStr0 (ODStrings.errForm)
  658.                 END; (* CASE obj.typ.form *)
  659.               |
  660.               eTypE, eTyp :
  661.                 mode := Typ; ReadInt (l); m := SHORT (l);
  662.                 IF class = eTypE THEN visible := Exp
  663.                 ELSE visible := NotExp
  664.                 END
  665.               |
  666.               eVar :
  667.                 mode := Var; ReadInt (a0); f.Read (SR, visible)
  668.               |
  669.               eXProc :
  670.                 mode := XProc; link := reversedList (lastpar [parlev]);
  671.                 DEC (parlev);
  672.               |
  673.               eLibCall : (* library call procedure *)
  674.                 mode := LibCall;
  675.                 ReadInt (a0); ReadInt (a1); visible := Exp;
  676.                 link := reversedList (lastpar [parlev]); DEC (parlev);
  677.               |
  678.               eM2Proc, eCProc, eAProc :
  679.                 IF class = eM2Proc THEN mode := M2Proc
  680.                 ELSIF class = eCProc THEN mode := CProc
  681.                 ELSE mode := AProc
  682.                 END;
  683.                 link := reversedList (lastpar [parlev]); DEC (parlev);
  684.                 ReadId (objName); NEW (symbol, str.Length (objName) + 1);
  685.                 COPY (objName, symbol^)
  686.               |
  687.             ELSE
  688.               OutStr0 (ODStrings.errClass)
  689.             END; (* CASE class *)
  690.             ReadId (objName);
  691.             IF InsertObj (objName, LocMod [m], mode, obj) THEN
  692.               obj.link := link; obj.typ := typ; obj.a0 := a0;
  693.               obj.a1 := a1; obj.a2 := a2; obj.visible := visible;
  694.               obj.symbol := symbol;
  695.               IF mode = Typ THEN
  696.                 IF typ.strobj = NIL THEN typ.strobj := obj END
  697.               END;
  698.             ELSIF mode = Typ THEN
  699.               FreeStruct (typ); struct [s] := obj.typ
  700.             END
  701.           |
  702.           ePointer .. eRecord :
  703.             (* structure *)
  704.             typ := AllocStruct (); typ.strobj := NIL;
  705.             typ.sysflg := OberonFlag;
  706.             ReadInt (l); typ.BaseTyp := struct [l];
  707.             ReadInt (l); typ.mno := SHORT (LocMod [l].a0);
  708.             CASE class OF
  709.               ePointer :
  710.                 typ.form := Pointer; typ.size := PtrSize; typ.n := 0;
  711.                 ReadInt (l); typ.sysflg := SHORT (l);
  712.                 ReadInt (typ.adr);
  713.                 IF
  714.                   (typ.BaseTyp.form = DynArr) & (typ.sysflg = OberonFlag)
  715.                 THEN
  716.                   typ.size := typ.BaseTyp.size
  717.                 END
  718.               |
  719.               eProcTyp :
  720.                 typ.form := ProcTyp; typ.size := ProcSize;
  721.                 typ.link := reversedList (lastpar [parlev]);
  722.                 DEC (parlev);
  723.               |
  724.               eArray :
  725.                 typ.form := Array; ReadInt (typ.size);
  726.                 ReadInt (typ.adr); ReadInt (l); typ.n := SHORT (l);
  727.               |
  728.               eDynArr :
  729.                 typ.form := DynArr; ReadInt (typ.size);
  730.                 ReadInt (typ.adr);
  731.               |
  732.               eRecord :
  733.                 typ.form := Record;
  734.                 ReadInt (typ.size); typ.n := 0;
  735.                 typ.link := reversedList2 (lastfld [fldlev]);
  736.                 DEC (fldlev);
  737.                 IF typ.BaseTyp = notyp THEN
  738.                   typ.BaseTyp := NIL; typ.n := 0;
  739.                 ELSE
  740.                   typ.n := typ.BaseTyp.n + 1;
  741.                 END;
  742.                 ReadInt (l); typ.sysflg := SHORT (l);
  743.                 ReadInt (typ.adr); (* of descriptor *)
  744.               |
  745.             ELSE
  746.               OutStr0 (ODStrings.errClass)
  747.             END; (* CASE class *)
  748.             struct [strno] := typ; INC (strno);
  749.           |
  750.           eParList : (* parameter list start *)
  751.             IF parlev < maxParLev - 1 THEN
  752.               INC (parlev); lastpar [parlev] := NIL;
  753.             ELSE
  754.               OutStr0 (ODStrings.errParLists)
  755.             END
  756.           |
  757.           eValPar, eVarPar, eVarArg :
  758.           (* parameter *)
  759.             obj := AllocObj ();
  760.             IF class = eValPar THEN obj.mode := Var
  761.             ELSIF class = eVarPar THEN obj.mode := Ind
  762.             ELSE obj.mode := VarArg
  763.             END;
  764.             ReadInt (l); obj.typ := struct [l];
  765.             ReadInt (obj.a0); ReadId (objName);
  766.             obj.name := InsertName (objName);
  767.             obj.link := lastpar [parlev]; lastpar [parlev] := obj
  768.           |
  769.           eFldList : (* start field list *)
  770.             IF fldlev < maxParLev - 1 THEN
  771.               INC (fldlev); lastfld [fldlev] := NIL;
  772.             ELSE
  773.               OutStr0 (ODStrings.errFieldLists)
  774.             END
  775.           |
  776.           eFld :
  777.             obj := AllocObj ();  obj.mode := Fld; obj.link := NIL;
  778.             ReadInt (l); obj.typ := struct [l];
  779.             ReadInt (obj.a0); f.Read (SR, obj.visible);
  780.             ReadId (objName); obj.name := InsertName (objName);
  781.             obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  782.           |
  783.           eTProcE : (* exported type-bound procedure *)
  784.             obj := AllocObj (); obj.mode := TProc;
  785.             ReadInt (l); typ := struct [l];
  786.             ReadInt (l); obj.typ := struct [l];
  787.             ReadInt (obj.a0); ReadId (objName);
  788.             obj.name := InsertName (objName);
  789.             obj.a1 := typ.n; obj.visible := Exp;
  790.             obj.link := reversedList (lastpar [parlev]); DEC (parlev);
  791.             obj.link.a2 := -1; obj.left := typ.link; typ.link := obj;
  792.           |
  793.           eTProc : (* hidden type-bound procedure *)
  794.             obj := AllocObj (); obj.mode := TProc; obj.typ := notyp;
  795.             ReadInt (l); typ := struct [l];
  796.             ReadInt (obj.a0); ReadId (objName);
  797.             obj.name := InsertName (objName);
  798.             obj.a1 := typ.n; obj.visible := Exp;
  799.             obj.link := NIL; obj.left := typ.link; typ.link := obj;
  800.           |
  801.           eHPtr : (* hidden pointer field *)
  802.             obj := AllocObj (); obj.mode := HPtr;
  803.             ReadInt (obj.a0); obj.name := -1; obj.typ := notyp;
  804.             obj.visible := NotExp; obj.link := NIL;
  805.             obj.left := lastfld [fldlev]; lastfld [fldlev] := obj
  806.           |
  807.           eHProc : (* hidden procedure field *)
  808.             ReadInt (l);
  809.           |
  810.           eFixup : (* fixup pointer typ *)
  811.             ReadInt (l); typ := struct [l];
  812.             ReadInt (l);
  813.             IF typ.BaseTyp = undftyp THEN
  814.               typ.BaseTyp := struct [l];
  815.               IF typ.BaseTyp.form = DynArr THEN
  816.                 typ.size := typ.BaseTyp.size;
  817.               END
  818.             END
  819.           |
  820.           eMod : (* module anchor *)
  821.             ReadLInt (k);
  822.             ReadId (objName); modname := InsertName (objName);
  823.             IF nofLmod = 0 THEN COPY (objName, name) END;
  824.             i := 0;
  825.             WHILE (i < nofGmod) & (modname # GlbMod [i].name) DO
  826.               INC (i);
  827.             END;
  828.             IF i < nofGmod THEN (* module already present *)
  829.               IF k # GlbMod [i].a1 THEN OutStr0 (ODStrings.errBadKey) END;
  830.               modobj := GlbMod [i];
  831.             ELSE
  832.               NEW (modobj);
  833.               IF nofGmod < maxImps THEN
  834.                 GlbMod [nofGmod] := modobj; INC (nofGmod);
  835.               ELSE
  836.                 OutStr0 (ODStrings.errGlbMod)
  837.               END;
  838.               modobj.mode := NotYetExp; modobj.name := modname;
  839.               modobj.a1 := k; modobj.a0 := nofGmod;
  840.               modobj.link := NIL; modobj.visible := NotExp;
  841.               IF class = eMod THEN modobj.a2 := 0 ELSE modobj.a2 := 1 END;
  842.             END;
  843.             IF nofLmod < maxMod THEN
  844.               LocMod [nofLmod] := modobj; INC (nofLmod)
  845.             ELSE
  846.               OutStr0 (ODStrings.errLocMod)
  847.             END
  848.           |
  849.           eExtLib : (* External library *)
  850.             ReadId (objName); ExtLib (objName)
  851.           |
  852.         ELSE
  853.           OutStr0 (ODStrings.errClass)
  854.         END; (* CASE class *)
  855.       END; (* LOOP *)
  856.       OpenScope (1); topScope.link := LocMod [0].link;
  857.       result := TRUE
  858.     ELSE
  859.       OutStr0 (ODStrings.errBadTag)
  860.     END;
  861.     f.Set (SR, NIL, 0); f.Close (SymFile)
  862.   ELSE
  863.     OutStr1 (ODStrings.errOpen, FileName)
  864.   END;
  865.   RETURN result
  866. END Import;
  867.  
  868. (*--- EXPORT ---------------------------------*)
  869.  
  870. (*------------------------------------*)
  871. PROCEDURE Write ( ch : CHAR );
  872. BEGIN
  873.   f.Write (SR, ch)
  874. END Write;
  875.  
  876. (*------------------------------------*)
  877. PROCEDURE WriteStr ( str : ARRAY OF CHAR );
  878. BEGIN
  879.   f.WriteBytes (SR, str, SYS.STRLEN (str))
  880. END WriteStr;
  881.  
  882. (*------------------------------------*)
  883. PROCEDURE Indent ();
  884.  
  885.   VAR i : INTEGER;
  886.  
  887. BEGIN
  888.   FOR i := 1 TO indentLevel DO
  889.     Write (" "); Write (" ")
  890.   END
  891. END Indent;
  892.  
  893. (*------------------------------------*)
  894. PROCEDURE WriteInt ( val : LONGINT );
  895.  
  896.   VAR i : INTEGER; x0 : LONGINT; a : ARRAY 11 OF CHAR;
  897.  
  898. BEGIN (* WriteInt *)
  899.   i := 0;
  900.   IF val < 0 THEN
  901.     IF val = MIN (LONGINT) THEN WriteStr ("-2147483648"); RETURN
  902.     ELSE x0 := -val
  903.     END
  904.   ELSE x0 := val
  905.   END;
  906.   REPEAT
  907.     a [i] := CHR (x0 MOD 10 + 30H); x0 := x0 DIV 10; INC (i)
  908.   UNTIL x0 = 0;
  909.   IF val < 0 THEN Write ("-") END;
  910.   REPEAT DEC (i); Write (a [i]) UNTIL i = 0
  911. END WriteInt;
  912.  
  913. (*------------------------------------*)
  914. PROCEDURE WriteHex ( val : LONGINT );
  915.  
  916.   VAR i : INTEGER; y : LONGINT; a : ARRAY 10 OF CHAR;
  917.  
  918. BEGIN (* WriteHex *)
  919.   i := 0; Write ("0");
  920.   REPEAT
  921.     y := val MOD 10H;
  922.     IF y < 10 THEN a [i] := CHR (y + 30H) ELSE a [i] := CHR (y + 37H) END;
  923.     val := val DIV 10H; INC (i)
  924.   UNTIL (val = 0) OR (i = 8);
  925.   REPEAT DEC (i); Write (a [i]) UNTIL i = 0
  926. END WriteHex;
  927.  
  928. (*------------------------------------*)
  929. PROCEDURE WriteReal ( val : LONGINT );
  930.  
  931.   VAR e, n : INTEGER; x, x0 : REAL; d : ARRAY 9 OF CHAR;
  932.  
  933. BEGIN (* WriteReal *)
  934.   x := SYS.VAL (REAL, val);
  935.   e := Reals.Expo (x); n := 8;
  936.   (* there are 2 < n <= 8 digits to be written *)
  937.   IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  938.   e := (e - 64) * 77 DIV 256;
  939.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  940.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  941.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  942.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  943.   Reals.Convert (x, n, d);
  944.   DEC (n); Write (d [n]); Write (".");
  945.   REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  946.   Write ("E");
  947.   IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  948.   Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
  949. END WriteReal;
  950.  
  951. (*------------------------------------*)
  952. PROCEDURE WriteLReal ( val1, val2 : LONGINT );
  953. BEGIN (* WriteLReal *)
  954.   WriteReal (val1)
  955. END WriteLReal;
  956.  
  957. (*------------------------------------*)
  958. PROCEDURE WriteSet ( val : LONGINT );
  959.  
  960.   VAR set : SET; bit : SHORTINT; comma : BOOLEAN;
  961.  
  962. BEGIN (* WriteSet *)
  963.   set := SYS.VAL (SET, val); comma := FALSE;
  964.   Write ("{");
  965.   FOR bit := 0 TO 31 DO
  966.     IF bit IN set THEN
  967.       IF comma THEN Write (",") END;
  968.       WriteInt (bit); comma := TRUE
  969.     END
  970.   END;
  971.   Write ("}");
  972. END WriteSet;
  973.  
  974. (*------------------------------------*)
  975. PROCEDURE WriteBoolean ( val : LONGINT );
  976. BEGIN
  977.   IF val = 0 THEN WriteStr ("TRUE")
  978.   ELSE WriteStr ("FALSE")
  979.   END
  980. END WriteBoolean;
  981.  
  982. (*------------------------------------*)
  983. PROCEDURE WriteHeader ( mname : ARRAY OF CHAR );
  984.  
  985.   VAR i : INTEGER;
  986.  
  987. <*$CopyArrays-*>
  988. BEGIN (* WriteHeader *)
  989.   WriteStr ("DEFINITION "); WriteStr (mname);
  990.   IF external & (nofExtLib > 0) THEN
  991.     WriteStr (" ["); i := 0;
  992.     LOOP
  993.       GetName (extLib [i]); INC (i);
  994.       Write ('"'); WriteStr (name); Write ('"');
  995.       IF i >= nofExtLib THEN EXIT END;
  996.       WriteStr (", ")
  997.     END;
  998.     Write ("]");
  999.   END;
  1000.   WriteStr (";\n\n");
  1001.   WriteStr ("(* Created using "); WriteStr (ODRev.vers); WriteStr (" *)\n")
  1002. END WriteHeader;
  1003.  
  1004. (*------------------------------------*)
  1005. PROCEDURE WriteImports ();
  1006.  
  1007.   VAR i : INTEGER;
  1008.  
  1009. BEGIN (* WriteImports *)
  1010.   IF nofGmod > 1 THEN
  1011.     WriteStr ("\nIMPORT\n"); INC (indentLevel); i := 1;
  1012.     LOOP
  1013.       GetName (GlbMod [i].name); INC (i);
  1014.       Indent (); WriteStr (name);
  1015.       IF i >= nofGmod THEN EXIT END;
  1016.       WriteStr (",\n");
  1017.     END;
  1018.     WriteStr (";\n");
  1019.     DEC (indentLevel)
  1020.   END;
  1021. END WriteImports;
  1022.  
  1023. (*------------------------------------*)
  1024. PROCEDURE WriteTrailer ( name : ARRAY OF CHAR );
  1025. <*$CopyArrays-*>
  1026. BEGIN (* WriteTrailer *)
  1027.   WriteStr ("\nEND "); WriteStr (name); WriteStr (".\n")
  1028. END WriteTrailer;
  1029.  
  1030. (*--------------------------------------
  1031. **
  1032. ** Performs an in-order traverse of the the symbol table,
  1033. ** applying the 'action' procedure to each node.
  1034. *)
  1035.  
  1036. PROCEDURE Scan ( action : ActionProc );
  1037.  
  1038.   (*------------------------------------*)
  1039.   PROCEDURE DoScan ( obj : Object );
  1040.   BEGIN (* DoScan *)
  1041.     IF obj # NIL THEN
  1042.       DoScan (obj.left);
  1043.       action (obj);
  1044.       DoScan (obj.right);
  1045.     END;
  1046.   END DoScan;
  1047.  
  1048. BEGIN (* Scan *)
  1049.   DoScan (topScope.link)
  1050. END Scan;
  1051.  
  1052. (*------------------------------------*)
  1053. PROCEDURE* WriteConsts ( obj : Object );
  1054.  
  1055.   VAR
  1056.     ch : CHAR; i : INTEGER;
  1057.  
  1058. BEGIN (* WriteConsts *)
  1059.   IF obj.mode = Con THEN
  1060.     IF ~wroteConst THEN
  1061.       WriteStr ("\nCONST\n\n"); wroteConst := TRUE
  1062.     END;
  1063.     GetName (obj.name);
  1064.     Indent (); WriteStr (name); WriteStr (" = ");
  1065.     CASE obj.typ.form OF
  1066.       Bool :
  1067.         WriteBoolean (obj.a0)
  1068.       |
  1069.       Char :
  1070.         ch := CHR (obj.a0);
  1071.         IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
  1072.           Write ('"'); Write (ch); Write ('"')
  1073.         ELSE
  1074.           WriteHex (ORD (ch)); Write ("X")
  1075.         END;
  1076.       |
  1077.       SInt, Int, LInt :
  1078.         WriteInt (obj.a0)
  1079.       |
  1080.       Real :
  1081.         WriteReal (obj.a0)
  1082.       |
  1083.       LReal :
  1084.         WriteLReal (obj.a0, obj.a1)
  1085.       |
  1086.       BSet, WSet, Set :
  1087.         WriteSet (obj.a0)
  1088.       |
  1089.       String :
  1090.         IF obj.a0 < 0 THEN (* This is a character literal *)
  1091.           ch := CHR (obj.a2);
  1092.           IF (ch >= " ") & (ch <= "~") OR (ch >= 0A0X) & (ch <= 0FFX) THEN
  1093.             Write ('"'); Write (ch); Write ('"')
  1094.           ELSE
  1095.             WriteHex (ORD (ch)); Write ("X")
  1096.           END
  1097.         ELSE
  1098.           Write ('"');
  1099.           FOR i := 1 TO obj.a1 - 1 DO Write ("?") END;
  1100.           Write ('"')
  1101.         END
  1102.       |
  1103.       NilTyp :
  1104.         WriteStr ("NIL")
  1105.       |
  1106.     ELSE
  1107.       WriteHex (obj.a0); Write ("H")
  1108.     END;
  1109.     WriteStr (";\n")
  1110.   END
  1111. END WriteConsts;
  1112.  
  1113. PROCEDURE^ WriteType ( obj : Object; typ : Struct );
  1114.  
  1115. (*------------------------------------*)
  1116. PROCEDURE WriteFields ( typ : Struct );
  1117.  
  1118.   VAR obj : Object;
  1119.  
  1120. BEGIN (* WriteFields *)
  1121.   IF typ # NIL THEN
  1122.     IF expand THEN WriteFields (typ.BaseTyp) END;
  1123.     obj := typ.link;
  1124.     WHILE obj # NIL DO
  1125.       IF (obj.mode = Fld) & (obj.name >= 0) THEN
  1126.         GetName (obj.name);
  1127.         Indent (); WriteStr (name);
  1128.         IF size THEN
  1129.           WriteStr (" <"); WriteInt (obj.a0); Write (">")
  1130.         END;
  1131.         IF obj.visible = RdOnly THEN WriteStr (" - : ")
  1132.         ELSE WriteStr (" : ")
  1133.         END;
  1134.         WriteType (NIL, obj.typ);
  1135.         WriteStr (";\n")
  1136.       ELSIF (obj.mode = HPtr) & size THEN
  1137.         Indent (); WriteStr ("[hidden ptr]");
  1138.         WriteStr (" <"); WriteInt (obj.a0); WriteStr ("> : POINTER;\n");
  1139.       END;
  1140.       obj := obj.left
  1141.     END;
  1142.   END;
  1143. END WriteFields;
  1144.  
  1145. (*------------------------------------*)
  1146. PROCEDURE WritePar ( par : Object; mode : INTEGER );
  1147.  
  1148. BEGIN (* WritePar *)
  1149.   IF par # NIL THEN
  1150.     IF par.mode = Ind THEN WriteStr ("VAR ") END;
  1151.     GetName (par.name); WriteStr (name);
  1152.     IF external & (mode IN {LibCall, AProc}) THEN
  1153.       WriteStr (" [");
  1154.       IF par.a0 >= 8 THEN Write ("A") ELSE Write ("D") END;
  1155.       WriteInt (par.a0 MOD 8);
  1156.       Write ("]")
  1157.     END;
  1158.     IF par.mode = VarArg THEN WriteStr (" ..: ")
  1159.     ELSE WriteStr (" : ")
  1160.     END;
  1161.     WriteType (NIL, par.typ)
  1162.   END
  1163. END WritePar;
  1164.  
  1165. (*------------------------------------*)
  1166. PROCEDURE WriteParList ( par : Object; mode : INTEGER );
  1167.  
  1168. BEGIN (* WriteParList *)
  1169.   IF par # NIL THEN
  1170.     INC (indentLevel);
  1171.     Write ("\n"); Indent (); WriteStr ("( ");
  1172.     INC (indentLevel);
  1173.     LOOP
  1174.       WritePar (par, mode);
  1175.       par := par.link;
  1176.       IF par = NIL THEN EXIT END;
  1177.       WriteStr (";\n"); Indent ()
  1178.     END;
  1179.     WriteStr (" )"); DEC (indentLevel, 2)
  1180.   END;
  1181. END WriteParList;
  1182.  
  1183. (*------------------------------------*)
  1184. PROCEDURE WriteTProcs ( typ : Struct );
  1185.  
  1186.   VAR obj, par : Object;
  1187.  
  1188. BEGIN (* WriteTProcs *)
  1189.   IF typ # NIL THEN
  1190.     IF expand THEN WriteTProcs (typ.BaseTyp) END;
  1191.     obj := typ.link;
  1192.     WHILE obj # NIL DO
  1193.       IF (obj.mode = TProc) & (obj.name >= 0) THEN
  1194.         Indent (); WriteStr ("PROCEDURE (");
  1195.         par := obj.link; WritePar (par, TProc); par := par.link;
  1196.         WriteStr (") ");
  1197.         GetName (obj.name); WriteStr (name);
  1198.         IF par # NIL THEN WriteParList (par, TProc)
  1199.         ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1200.         END;
  1201.         IF obj.typ # notyp THEN
  1202.           INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1203.           WriteType (NIL, obj.typ); DEC (indentLevel)
  1204.         END; (* IF *)
  1205.         WriteStr (";\n")
  1206.       END;
  1207.       obj := obj.left
  1208.     END;
  1209.   END;
  1210. END WriteTProcs;
  1211.  
  1212. (*------------------------------------*)
  1213. PROCEDURE WriteType ( obj : Object; typ : Struct );
  1214.  
  1215.   VAR
  1216.     mno : INTEGER; par : Object;
  1217.  
  1218. BEGIN (* WriteType *)
  1219.   IF (typ.strobj # NIL) & (typ.strobj # obj) THEN
  1220.     mno := typ.mno - 1;
  1221.     IF mno > 0 THEN
  1222.       GetName (GlbMod [mno].name);
  1223.       WriteStr (name); Write (".")
  1224.     END;
  1225.     GetName (typ.strobj.name); WriteStr (name);
  1226.     IF size THEN
  1227.       WriteStr (" <"); WriteInt (typ.size); Write (">")
  1228.     END
  1229.   ELSE
  1230.     CASE typ.form OF
  1231.       Pointer :
  1232.         WriteStr ("POINTER ");
  1233.         IF typ.sysflg # OberonFlag THEN
  1234.           Write ("["); WriteInt (typ.sysflg); WriteStr ("] ")
  1235.         END;
  1236.         WriteStr ("TO ");
  1237.         IF size THEN
  1238.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1239.         END;
  1240.         WriteType (NIL, typ.BaseTyp)
  1241.       |
  1242.       ProcTyp :
  1243.         WriteStr ("PROCEDURE");
  1244.         IF size THEN
  1245.           WriteStr (" <"); WriteInt (typ.size); Write (">")
  1246.         END;
  1247.         par := typ.link; IF par # NIL THEN WriteParList (par, XProc)
  1248.         ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1249.         END;
  1250.         IF typ.BaseTyp # notyp THEN
  1251.           INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1252.           WriteType (NIL, typ.BaseTyp); DEC (indentLevel)
  1253.         END
  1254.       |
  1255.       Array :
  1256.         WriteStr ("ARRAY "); WriteInt (typ.n); WriteStr (" OF ");
  1257.         IF size THEN
  1258.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1259.         END;
  1260.         WriteType (NIL, typ.BaseTyp)
  1261.       |
  1262.       DynArr :
  1263.         WriteStr ("ARRAY OF ");
  1264.         IF size THEN
  1265.           Write ("<"); WriteInt (typ.size); WriteStr ("> ")
  1266.         END;
  1267.         WriteType (NIL, typ.BaseTyp)
  1268.       |
  1269.       Record :
  1270.         WriteStr ("RECORD ");
  1271.         IF typ.sysflg # OberonFlag THEN
  1272.           Write ("["); WriteInt (typ.sysflg); WriteStr ("] ")
  1273.         END;
  1274.         IF typ.BaseTyp # NIL THEN
  1275.           Write ("(");
  1276.           WriteType (NIL, typ.BaseTyp);
  1277.           Write (")")
  1278.         END;
  1279.         Write ("\n");
  1280.         INC (indentLevel);
  1281.         WriteFields (typ);
  1282.         WriteTProcs (typ);
  1283.         DEC (indentLevel);
  1284.         Indent(); WriteStr ("END");
  1285.         IF size THEN
  1286.           WriteStr (" <"); WriteInt (typ.size); Write (">")
  1287.         END
  1288.       |
  1289.     ELSE
  1290.       OutStr0 (ODStrings.errType); HALT (d.fail)
  1291.     END; (* CASE *)
  1292.   END;
  1293. END WriteType;
  1294.  
  1295. (*------------------------------------*)
  1296. PROCEDURE* WriteTypes ( obj : Object );
  1297.  
  1298. BEGIN
  1299.   IF obj.mode = Typ THEN
  1300.     IF ~wroteType THEN
  1301.       WriteStr ("\nTYPE\n\n"); wroteType := TRUE
  1302.     END;
  1303.     GetName (obj.name);
  1304.     Indent (); WriteStr (name);
  1305.     IF obj.visible = Exp THEN WriteStr (" * = ")
  1306.     ELSE WriteStr (" = ")
  1307.     END;
  1308.     WriteType (obj, obj.typ);
  1309.     WriteStr (";\n\n")
  1310.   END
  1311. END WriteTypes;
  1312.  
  1313. (*------------------------------------*)
  1314. PROCEDURE* WriteVars ( obj : Object );
  1315.  
  1316. BEGIN (* WriteVars *)
  1317.   IF obj.mode = Var THEN
  1318.     IF ~wroteVar THEN
  1319.       WriteStr ("\nVAR\n\n"); wroteVar := TRUE
  1320.     END;
  1321.     GetName (obj.name);
  1322.     Indent (); WriteStr (name);
  1323.     IF size THEN
  1324.       WriteStr (" <"); WriteInt (obj.a0); Write (">")
  1325.     END;
  1326.     IF obj.visible = RdOnly THEN WriteStr (" - : ")
  1327.     ELSE WriteStr (" * : ")
  1328.     END;
  1329.     WriteType (NIL, obj.typ);
  1330.     WriteStr (";\n")
  1331.   END
  1332. END WriteVars;
  1333.  
  1334. (*------------------------------------*)
  1335. PROCEDURE* WriteProcs ( obj : Object );
  1336.  
  1337.   VAR
  1338.     par : Object;
  1339.  
  1340. BEGIN (* WriteProcs *)
  1341.   IF obj.mode IN {XProc, LibCall, M2Proc, CProc, AProc} THEN
  1342.     IF ~wroteProcs THEN
  1343.       WriteStr ("\n(* PROCEDURES *)\n\n"); wroteProcs := TRUE
  1344.     END;
  1345.     WriteStr ("PROCEDURE ");
  1346.     IF external & (obj.mode IN {M2Proc, CProc, AProc}) THEN
  1347.       Write ("[");
  1348.       CASE obj.mode OF
  1349.         M2Proc : WriteInt (1) |
  1350.         CProc : WriteInt (2) |
  1351.         AProc : WriteInt (4) |
  1352.       END;
  1353.       WriteStr ("] ")
  1354.     END;
  1355.     GetName (obj.name); WriteStr (name);
  1356.     IF external & (obj.mode # XProc) THEN
  1357.       IF obj.mode = LibCall THEN
  1358.         WriteStr (' ['); WriteInt (obj.a0); Write (']')
  1359.       ELSIF obj.mode # XProc THEN
  1360.         WriteStr (' ["'); WriteStr (obj.symbol^); WriteStr ('"]')
  1361.       END;
  1362.     END;
  1363.     par := obj.link;
  1364.     IF par # NIL THEN WriteParList (par, obj.mode)
  1365.     ELSIF obj.typ # notyp THEN WriteStr (" ()")
  1366.     END;
  1367.     IF obj.typ # notyp THEN
  1368.       INC (indentLevel); Write ("\n"); Indent (); WriteStr (": ");
  1369.       WriteType (NIL, obj.typ); DEC (indentLevel)
  1370.     END; (* IF *)
  1371.     WriteStr (";\n")
  1372.   END
  1373. END WriteProcs;
  1374.  
  1375. (*------------------------------------*)
  1376. PROCEDURE Export * ( fileName, name : ARRAY OF CHAR );
  1377.  
  1378.   VAR
  1379.     defFile : f.File;
  1380.  
  1381. BEGIN (* Export *)
  1382.   indentLevel := 0;
  1383.   defFile := f.New (fileName);
  1384.   IF defFile # NIL THEN
  1385.     OutStr ("\x9B\x4B >> "); OutStr (fileName); OutLn;
  1386.     f.Set (SR, defFile, 0);
  1387.  
  1388.     WriteHeader (name); WriteImports ();
  1389.     INC (indentLevel); Scan (WriteConsts); DEC (indentLevel);
  1390.     INC (indentLevel); Scan (WriteTypes); DEC (indentLevel);
  1391.     INC (indentLevel); Scan (WriteVars); DEC (indentLevel);
  1392.     Scan (WriteProcs);
  1393.     WriteTrailer (name);
  1394.  
  1395.     f.Set (SR, NIL, 0); f.Register (defFile)
  1396.   ELSE
  1397.     OutStr1 (ODStrings.errOpen, fileName)
  1398.   END;
  1399.   CloseScope()
  1400. END Export;
  1401.  
  1402. (*--- INITIALISATION ---------------------------------*)
  1403.  
  1404. (*------------------------------------*)
  1405. PROCEDURE InitStruct (VAR typ : Struct; f : INTEGER);
  1406.  
  1407. BEGIN (* InitStruct *)
  1408.   typ := AllocStruct (); typ.form := f; typ.size := 1
  1409. END InitStruct;
  1410.  
  1411. (*------------------------------------*)
  1412. PROCEDURE EnterTyp (
  1413.   name : ARRAY OF CHAR; form, size : INTEGER; VAR res: Struct);
  1414.  
  1415.   VAR obj : Object; typ : Struct;
  1416.  
  1417. <*$CopyArrays-*>
  1418. BEGIN (* EnterTyp *)
  1419.   Insert (name, obj, Typ); typ := AllocStruct ();
  1420.   obj.typ := typ; obj.visible := Exp;
  1421.   typ.form := form; typ.strobj := obj; typ.size := size;
  1422.   res := typ;
  1423. END EnterTyp;
  1424.  
  1425. BEGIN (* ODT *)
  1426.   nameSize := 0; topScope := NIL;
  1427.   InitStruct (undftyp, Undef); InitStruct (notyp, NoTyp);
  1428.   InitStruct (stringtyp, String); InitStruct (niltyp, NilTyp);
  1429.   OpenScope (0);
  1430.  
  1431.   (* initialisation of module SYSTEM *)
  1432.  
  1433.   EnterTyp ("SYSTEM.BYTESET", BSet, BSetSize, bsettyp);
  1434.   EnterTyp ("SYSTEM.WORDSET", WSet, WSetSize, wsettyp);
  1435.   EnterTyp ("SYSTEM.PTR", PtrTyp, PtrSize, ptrtyp);
  1436.   EnterTyp ("SYSTEM.BPTR", BPtrTyp, PtrSize, bptrtyp);
  1437.   EnterTyp ("SYSTEM.ADDRESS", AdrTyp, PtrSize, adrtyp);
  1438.   EnterTyp ("SYSTEM.BYTE", Byte, ByteSize, bytetyp);
  1439.   EnterTyp ("SYSTEM.WORD", Word, WordSize, wordtyp);
  1440.   EnterTyp ("SYSTEM.LONGWORD", Longword, LongSize, lwordtyp);
  1441.   EnterTyp ("SYSTEM.TYPETAG", TagTyp, PtrSize, tagtyp);
  1442.  
  1443.   syslink := topScope.link; universe := topScope; topScope.link := NIL;
  1444.  
  1445.   (* initialisation of predeclared types and procedures *)
  1446.  
  1447.   EnterTyp ("CHAR", Char, CharSize, chartyp);
  1448.   EnterTyp ("SET", Set, SetSize, settyp);
  1449.   EnterTyp ("REAL", Real, RealSize, realtyp);
  1450.   EnterTyp ("INTEGER", Int, IntSize, inttyp);
  1451.   EnterTyp ("LONGINT", LInt, LIntSize, linttyp);
  1452.   EnterTyp ("LONGREAL", LReal, LRealSize, lrltyp);
  1453.   EnterTyp ("SHORTINT", SInt, SIntSize, sinttyp);
  1454.   EnterTyp ("BOOLEAN", Bool, BoolSize, booltyp);
  1455.  
  1456.   nameOrg := nameX;
  1457.   backupTab := nameTab; (* Save hash table for names so we can restore it *)
  1458. END ODT.
  1459.  
  1460. (*************************************************************************
  1461.  
  1462.   $Log: ODT.mod $
  1463.   Revision 1.5  1995/01/26  02:00:59  fjc
  1464.   - Release 1.5
  1465.  
  1466.   Revision 1.4  1994/09/26  12:15:26  fjc
  1467.   - Changed to process new symbol file format, with new
  1468.     object modes and system flags.
  1469.   - Improved format of output.
  1470.   - Replaced verbose flag with external and size.
  1471.  
  1472.   Revision 1.3  1994/08/08  16:35:10  fjc
  1473.   Release 1.4
  1474.  
  1475.   Revision 1.2  1994/07/22  13:54:09  fjc
  1476.   - Added code to handle FProc objects.
  1477.  
  1478.   Revision 1.1  1994/07/09  21:54:16  fjc
  1479.   Initial revision
  1480.  
  1481. *************************************************************************)
  1482.